Ακολουθίες-Σειρές-Γινόμενα

Ακολουθίες

Σύγκλιση ακολουθίας

Clear["Global`*"]
l = 1;
aa = 1;
a[n_] := aa*Sin[Pi*n/6]/n+l
e = 0.1;
sol1 := NSolve[a[n]==l+e, n,Reals];
maxSol1 := Length[sol1];
n01 := Floor[n/.sol1[[maxSol1]]]+1;
sol2 := NSolve[a[n]==l-e, n,Reals];
maxSol2 := Length[sol2];
n02 := Floor[n/.sol2[[maxSol2]]]+1;
n0 := Max[n01,n02]
nInf = 150;
pl1 := ListPlot[Table[{n,a[n]},{n,1,n0-1}], PlotStyle -> Green,Background-> Gray,Filling->Axis, PlotRange -> {{0,nInf},{0,1.1(aa+l)}}];
pl2 := ListPlot[Table[{n,a[n]},{n,n0,nInf}], PlotStyle -> Red,Background-> Gray,Filling->Axis, PlotRange -> {{0,nInf},{0,1.1(aa+l)}}];
l1 := Plot[l-e,{x,0,nInf}, PlotStyle -> {Black, Dashed, Thin}];
l2 := Plot[e+l,{x,0,nInf}, PlotStyle -> {Black, Dashed, Thin}];
Show[pl1,pl2,l1,l2]
e = 0.01;
Show[pl1,pl2,l1,l2]

Αναδρομικές ακολουθίες

Ορισμός

Clear["Global`*"]
a[1] = 1
a[n_] := a[n] = (2 n)/(n - 1) + a[n - 1]
tableAn = Table[{n, a[n]}, {n, 1, 12}] // N;
TableForm[tableAn, 
 TableHeadings -> {None, {"n", 
    Subscript[a,n]}}]

1

\begin{pmatrix} "n" & (*SbB[*)Subscript[a & n](*]SbB*) \\ 1.` & 1.` \\ 2.` & 5.` \\ 3.` & 8.` \\ 4.` & 10.666666666666666` \\ 5.` & 13.166666666666666` \\ 6.` & 15.566666666666666` \\ 7.` & 17.9` \\ 8.` & 20.185714285714287` \\ 9.` & 22.435714285714287` \\ 10.` & 24.65793650793651` \\ 11.` & 26.857936507936508` \\ 12.` & 29.03975468975469` \end{pmatrix}

Γράφημα König-Lemeray

Clear["Global`*"]
n = 100; (* Αριθμός επαναλήψεων *)

koeningLemeray[a_, x0_] := 
  Module[{f, seq, p, colors}, 
  (*Εδώ ο τύπος της συνάρτησης*)
    f[x_] := Which[0<=x<=1/2,2x, 1/2<x<=1, 2(1 - x)];
      (*Εδώ ο τύπος της συνάρτησης*)
    seq = NestList[f, x0, n];
    p = Partition[seq, 2, 1];
    colors = ColorData["SunsetColors"] /@ 
      Rescale[Range[Length[p]], {1, Length[p]}]; (* Αντιστοίχιση χρωμάτων *)

    Plot[{Style[f[x], Red], Style[x, Blue]}, {x, 0,1}, 
      PlotRange -> All,Background -> Lighter[Gray],
      Epilog -> (Table[{Thick, Opacity[0.8], colors[[i]], 
          Line[{{p[[i, 1]], p[[i, 1]]}, {p[[i, 1]], p[[i, 2]]}, 
            {p[[i, 2]], p[[i, 2]]}}]}, {i, Length[p]}] // Flatten), 
      AxesLabel -> {Subscript["x","n"], Subscript["x","n+1"]}, 
      PlotLabel -> "cobweb plot", 
      ImageSize -> 500]];

koeningLemeray[1+Sqrt[6], 251/954]

Γράφημα διακλάδωσης

Clear["Global`*"]

logisticMap[r_, x_] := r x (1 - x)

(* Λιγότερες επαναλήψεις και μεγαλύτερο βήμα για τα r *)
bifurcationData = Flatten[
   Table[
    {r, #} & /@ NestList[logisticMap[r, #] &, RandomReal[], 500][[400 ;;]],
    {r, 2.8, 4, 0.001}], 1];

pl= ListPlot[bifurcationData, 
 PlotStyle -> Directive[PointSize[0.001], Opacity[1]], 
 AxesLabel -> {"λ", "b"}, 
 AxesStyle -> White,          (* Αλλάζει το χρώμα των αξόνων σε λευκό *)
 TicksStyle -> White,         (* Αλλάζει το χρώμα των ticks σε λευκό *)
 ImageSize -> Large, 
 PlotRange -> {{2.8, 4}, {0, 1}}, 
 ColorFunction -> (ColorData["DarkRainbow"][#2] &), 
 Background -> Black, 
 ColorFunctionScaling -> True]

Τεστ 0-1

Εξαγωγή $K_c$

Ακολουθία προς μελέτη.

Clear["Global`*"]
λ=3.5;	
x[0] = 0.123;
x[n_] := x[n] = λ x[n - 1](1-x[n-1])

nInf = 1000;
values = Table[x[n], {n, 0, nInf}];
n0=Floor[nInf/10];
c=0.4;
pc = Table[Sum[values[[j]]Cos[j c],{j,1,n}],{n,1,nInf}];
qc = Table[Sum[values[[j]]Sin[j c],{j,1,n}],{n,1,nInf}];

ListPlot[Transpose[{pc,qc}], PlotRange->All, AxesLabel->{Subscript["p","c"],Subscript["q","c"]}, 
Background->Lighter[Gray], PlotStyle->Red, ImageSize->500]

mc = Table[Sum[(pc[[j+n]]-pc[[j]])^2+(qc[[j+n]]-qc[[j]])^2,{j,1,nInf-n0}],{n,1,n0}]/(nInf-n0);
ef = Mean[values];
vosc[n_] := ef^2 (1-Cos[n c])/(1-Cos[c]);
dc[n_] := mc[[n]]-vosc[n];
dcValues = Table[dc[n],{n,1,n0}];
valuesCut = Take[values,n0];

nValues = Table[n,{n,1,n0}];
kc = Correlation[nValues,dcValues]
kcPalio = Correlation[nValues,mc]

-0.01781086575136674`

-0.04407647026767079`

Εξαγωγή $K$

Clear["Global`*"]

kappa[c_, values_] := Module[
  {nInf, n0, pc, qc, mc, ef, vosc, dc, dcValues, nValues, kc},
  
  (* Αρχικοποίηση μεταβλητών *)
  nInf = Length[values] - 1;
  n0 = Floor[nInf/10];
  
  (* Υπολογισμός των pc και qc *)
  pc = Table[Sum[values[[j]] Cos[j c], {j, 1, n}], {n, 1, nInf}];
  qc = Table[Sum[values[[j]] Sin[j c], {j, 1, n}], {n, 1, nInf}];
  
  (* Υπολογισμός του mc *)
  mc = Table[
    Sum[(pc[[j + n]] - pc[[j]])^2 + (qc[[j + n]] - qc[[j]])^2, {j, 1, nInf - n0}], 
    {n, 1, n0}] / (nInf - n0);
  
  (* Υπολογισμός του μέσου όρου των values *)
  ef = Mean[values];
  
  (* Ορισμός της συνάρτησης vosc *)
  vosc[n_] := ef^2 (1 - Cos[n c]) / (1 - Cos[c]);
  
  (* Υπολογισμός του dc *)
  dc[n_] := mc[[n]] - vosc[n];
  
  (* Δημιουργία της λίστας dcValues *)
  dcValues = Table[dc[n], {n, 1, n0}];
  
  nValues = Table[n,{n,1,n0}];

  
  (* Υπολογισμός της συσχέτισης kc *)
  kc = Correlation[nValues, dcValues];
  
  (* Επιστροφή του kc *)
  kc
]

λ=3.95;	
x[0] = 0.123;
x[n_] := x[n] = λ x[n - 1](1-x[n-1])
nInf = 100;
values = Table[x[n], {n, 0, nInf}];

(* Δημιουργία 100 τυχαίων τιμών για το c στο διάστημα (0, π) *)
randomCValues = RandomReal[{0, Pi}, 100];

(* Υπολογισμός της λίστας kappa[c, values] για κάθε τυχαίο c *)
kappaList = Table[kappa[c, values], {c, randomCValues}];

(* Υπολογισμός της διάμεσου της λίστας kappaList *)
medianKappa = Median[kappaList];

(* Εμφάνιση της διάμεσου *)
medianKappa

0.996449127179845`

Για μια αυτοματοποιημένη εκδοχή ορίζουμε τις συναρτήσεις:

Clear["Global`*"]

(* Ορισμός της συνάρτησης kappa *)
kappa[c_, values_] := Module[
  {nInf, n0, pc, qc, mc, ef, vosc, dc, dcValues, nValues, kc},
  
  (* Αρχικοποίηση μεταβλητών *)
  nInf = Length[values] - 1;
  n0 = Floor[nInf/10];
  
  (* Υπολογισμός των pc και qc *)
  pc = Table[Sum[values[[j]] Cos[j c], {j, 1, n}], {n, 1, nInf}];
  qc = Table[Sum[values[[j]] Sin[j c], {j, 1, n}], {n, 1, nInf}];
  
  (* Υπολογισμός του mc *)
  mc = Table[
    Sum[(pc[[j + n]] - pc[[j]])^2 + (qc[[j + n]] - qc[[j]])^2, {j, 1, nInf - n0}], 
    {n, 1, n0}] / (nInf - n0);
  
  (* Υπολογισμός του μέσου όρου των values *)
  ef = Mean[values];
  
  (* Ορισμός της συνάρτησης vosc *)
  vosc[n_] := ef^2 (1 - Cos[n c]) / (1 - Cos[c]);
  
  (* Υπολογισμός του dc *)
  dc[n_] := mc[[n]] - vosc[n];
  
  (* Δημιουργία της λίστας dcValues *)
  dcValues = Table[dc[n], {n, 1, n0}];
  
  nValues = Table[n, {n, 1, n0}];
  
  (* Υπολογισμός της συσχέτισης kc *)
  kc = Correlation[nValues, dcValues];
  
  (* Επιστροφή του kc *)
  kc
]

(* Ορισμός της συνάρτησης medianKappa *)
medianKappa[values_] := Module[
  {randomCValues, kappaList},
  
  (* Δημιουργία 100 τυχαίων τιμών για το c στο διάστημα (0, π) *)
  randomCValues = RandomReal[{0, Pi}, 100];
  
  (* Υπολογισμός της λίστας kappa[c, values] για κάθε τυχαίο c *)
  kappaList = Table[kappa[c, values], {c, randomCValues}];
  
  (* Υπολογισμός και επιστροφή της διάμεσου της λίστας kappaList *)
  Median[kappaList]
]


(* Παράδειγμα χρήσης *)
λ = 3.55;	
x[0] = 0.123;
x[n_] := x[n] = λ x[n - 1] (1 - x[n - 1]);
nInf = 1000;
values = Table[x[n], {n, 0, nInf}];

(* Κλήση της συνάρτησης medianKappa *)
result = medianKappa[values];

(* Εμφάνιση του αποτελέσματος *)
result

-0.013773322496441021`

Εκθέτης Lyapunov

Ορισμός της λογιστικής απεικόνισης

logisticMap[r_, x_] := r x (1 - x)

Υπολογισμός του εκθέτη Lyapunov για κάθε r

lyapunovExponent[r_, x0_, n_] := Module[{x = x0, sum = 0},
  Do[
    x = logisticMap[r, x];
    sum += Log[Abs[r (1 - 2 x)]];
    , {i, n}];
  sum/n
]

Παράμετροι

rMin = 3.5;
rMax = 4.0;
numPoints = 1000;
nIter = 1000; (* Αριθμός επαναλήψεων για να αγνοήσουμε το αρχικό transience *)
nLyap = 500; (* Αριθμός επαναλήψεων για τον υπολογισμό του Lyapunov *)

Υπολογισμός των εκθετών Lyapunov.

rValues = Range[rMin, rMax, (rMax - rMin)/numPoints];
lyapValues = Table[lyapunovExponent[r, 0.5, nLyap], {r, rValues}];

Γράφημα

pl=ListLinePlot[Transpose[{rValues, lyapValues}],
  AxesLabel -> {"λ", "Lyapunov Exponent"},
  PlotRange -> All,
  GridLines -> Automatic,
  Epilog -> {Dashed, Line[{{rMin, 0}, {rMax, 0}}]},
  Background -> Lighter[Gray]]

Εύρεση ακολουθίας

Από μια λίστα αριθμών

Clear["Global`*"]
FindSequenceFunction[{1, 1, 2, 3, 5, 8, 13}, n]
FindSequenceFunction[Table[{2 n, 2^n}, {n, 10}], n]

\(Fibonacci[n]\)

2^{n/2}

Από αναδρομικό τύπο

eq = a[n + 1] == 2 a[n] + 1;
init = a[0] == 1;
RSolve[eq, a[n], n]
RSolve[{eq, init}, a[n], n]

{{a(n)\to -1+2^{n}+(2^{-1+n}) C_{1}}}

{{a(n)\to -1+2^{1+n}}}

Συστήματα

eq1 = a[n + 1] == a[n] - b[n] + 1;
eq2 = b[n + 1] == a[n] + b[n] - 2;
RSolve[{eq1, eq2}, {a[n], b[n]}, n]

{{a(n)\to 2+(\frac{1}{2}) ({(1-I)}^{n}+{(1+I)}^{n}) C_{1}-(\frac{1}{2}) I ({(1-I)}^{n}-{(1+I)}^{n}) C_{2},b(n)\to 1+(\frac{1}{2}) I ({(1-I)}^{n}-{(1+I)}^{n}) C_{1}+(\frac{1}{2}) ({(1-I)}^{n}+{(1+I)}^{n}) C_{2}}}

Clear["Global`*"]
eqA = a[n + 1] == A*AA*a[n] + r*DA*d[n]
eqD = d[n + 1] == A*AD*a[n] + r*DD*d[n]
AD = 1 - AA
DD = 1 - DA
r = 1
A = 1
RSolve[{eqA, a[0] == a0, eqD, d[0] == d0}, {a[n], d[n]}, n]

\[a(1+n)=A AA a(n)+DA r d(n)\]

\[d(1+n)=A AD a(n)+DD r d(n)\]

1-AA

1-DA

1

{{a(n)\to \frac{-a0 ({(AA-DA)}^{n})+a0 AA ({(AA-DA)}^{n})-a0 DA-d0 DA+d0 ({(AA-DA)}^{n}) DA}{-1+AA-DA},d(n)\to -\frac{a0-a0 AA+d0-AA d0-a0 ({(AA-DA)}^{n})+a0 AA ({(AA-DA)}^{n})+d0 ({(AA-DA)}^{n}) DA}{-1+AA-DA}}}

Απεικόνιση ακολουθίας

Ορισμός ακολουθίας

Clear["Global`*"]
a[1] = 1;
a[n_] := a[n] = (2 n)/(n - 1) + a[n - 1]

Λίστα σημείων

table1 = Table[a[n], {n, 1, 20}];
table2 = Table[{a[n], a[n + 1] - 5 a[n]}, {n, 1, 10}];

Βασικό γράφημα

ListPlot[table1]
ListPlot[table2]

Παρουσίαση πλαισίου

ListPlot[table1, PlotTheme -> "Scientific"]
ListPlot[table1, PlotTheme -> "Detailed"]
ListPlot[table1, PlotTheme -> "Classic"]

Γραμμές ως πάνω

Από τον οριζόντιο άξονα.

ListPlot[table1, Filling -> Axis]

Μεταξύ δύο ακολουθιών

data1 = Sqrt[Range[40]] - 2;
data2 = Log[Range[40]];
ListPlot[{data1, data2}, Filling -> {1 -> {{2}, {Red, Blue}}}]

Σειρές

Clear["Global`*"]
Sum[1/2^i, {i, 1, n}]
Sum[x^n, {n, 0, Infinity}]
Sum[x^n, {n, 0, Infinity}, GenerateConditions -> True]
Sum[1/i^2, {i, 1, Infinity}]

(2^{-n}) (-1+2^{n})

\frac{1}{1-x}

\frac{1}{1-x}\,\text{ if }\,\left|x\right|<1

(\frac{1}{6}) ({\pi }^{2})

Γινόμενα

Clear["Global`*"]
Product[1/2^i, {i, 1, n}]
Product[(1 + 1/2^i), {i, 1, Infinity}]

2^{-\frac{1}{2} n (1+n)}

(\frac{1}{2}) QPochhammer[-1,\frac{1}{2}]